home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / src / lib / tcl / dist6.3 / tclUnixAZ.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-04-16  |  42.0 KB  |  1,688 lines
  1. /* 
  2.  * tclUnixAZ.c --
  3.  *
  4.  *    This file contains the top-level command procedures for
  5.  *    commands in the Tcl core that require UNIX facilities
  6.  *    such as files and process execution.  Much of the code
  7.  *    in this file is based on earlier versions contributed
  8.  *    by Karl Lehenbauer, Mark Diekhans and Peter da Silva.
  9.  *
  10.  * Copyright 1991 Regents of the University of California
  11.  * Permission to use, copy, modify, and distribute this
  12.  * software and its documentation for any purpose and without
  13.  * fee is hereby granted, provided that this copyright
  14.  * notice appears in all copies.  The University of California
  15.  * makes no representations about the suitability of this
  16.  * software for any purpose.  It is provided "as is" without
  17.  * express or implied warranty.
  18.  */
  19.  
  20. #ifndef lint
  21. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUnixAZ.c,v 1.36 92/04/16 13:32:02 ouster Exp $ SPRITE (Berkeley)";
  22. #endif /* not lint */
  23.  
  24. #include "tclInt.h"
  25. #include "tclUnix.h"
  26.  
  27. /*
  28.  * The variable below caches the name of the current working directory
  29.  * in order to avoid repeated calls to getwd.  The string is malloc-ed.
  30.  * NULL means the cache needs to be refreshed.
  31.  */
  32.  
  33. static char *currentDir =  NULL;
  34.  
  35. /*
  36.  * Prototypes for local procedures defined in this file:
  37.  */
  38.  
  39. static int        CleanupChildren _ANSI_ARGS_((Tcl_Interp *interp,
  40.                 int numPids, int *pidPtr, int errorId));
  41. static char *        GetFileType _ANSI_ARGS_((int mode));
  42. static int        StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
  43.                 char *varName, struct stat *statPtr));
  44.  
  45. /*
  46.  *----------------------------------------------------------------------
  47.  *
  48.  * Tcl_CdCmd --
  49.  *
  50.  *    This procedure is invoked to process the "cd" Tcl command.
  51.  *    See the user documentation for details on what it does.
  52.  *
  53.  * Results:
  54.  *    A standard Tcl result.
  55.  *
  56.  * Side effects:
  57.  *    See the user documentation.
  58.  *
  59.  *----------------------------------------------------------------------
  60.  */
  61.  
  62.     /* ARGSUSED */
  63. int
  64. Tcl_CdCmd(dummy, interp, argc, argv)
  65.     ClientData dummy;            /* Not used. */
  66.     Tcl_Interp *interp;            /* Current interpreter. */
  67.     int argc;                /* Number of arguments. */
  68.     char **argv;            /* Argument strings. */
  69. {
  70.     char *dirName;
  71.  
  72.     if (argc > 2) {
  73.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  74.         " dirName\"", (char *) NULL);
  75.     return TCL_ERROR;
  76.     }
  77.  
  78.     if (argc == 2) {
  79.     dirName = argv[1];
  80.     } else {
  81.     dirName = "~";
  82.     }
  83.     dirName = Tcl_TildeSubst(interp, dirName);
  84.     if (dirName == NULL) {
  85.     return TCL_ERROR;
  86.     }
  87.     if (currentDir != NULL) {
  88.     ckfree(currentDir);
  89.     currentDir = NULL;
  90.     }
  91.     if (chdir(dirName) != 0) {
  92.     Tcl_AppendResult(interp, "couldn't change working directory to \"",
  93.         dirName, "\": ", Tcl_UnixError(interp), (char *) NULL);
  94.     return TCL_ERROR;
  95.     }
  96.     return TCL_OK;
  97. }
  98.  
  99. /*
  100.  *----------------------------------------------------------------------
  101.  *
  102.  * Tcl_CloseCmd --
  103.  *
  104.  *    This procedure is invoked to process the "close" Tcl command.
  105.  *    See the user documentation for details on what it does.
  106.  *
  107.  * Results:
  108.  *    A standard Tcl result.
  109.  *
  110.  * Side effects:
  111.  *    See the user documentation.
  112.  *
  113.  *----------------------------------------------------------------------
  114.  */
  115.  
  116.     /* ARGSUSED */
  117. int
  118. Tcl_CloseCmd(dummy, interp, argc, argv)
  119.     ClientData dummy;            /* Not used. */
  120.     Tcl_Interp *interp;            /* Current interpreter. */
  121.     int argc;                /* Number of arguments. */
  122.     char **argv;            /* Argument strings. */
  123. {
  124.     OpenFile *filePtr;
  125.     int result = TCL_OK;
  126.  
  127.     if (argc != 2) {
  128.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  129.         " fileId\"", (char *) NULL);
  130.     return TCL_ERROR;
  131.     }
  132.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  133.     return TCL_ERROR;
  134.     }
  135.     ((Interp *) interp)->filePtrArray[fileno(filePtr->f)] = NULL;
  136.  
  137.     /*
  138.      * First close the file (in the case of a process pipeline, there may
  139.      * be two files, one for the pipe at each end of the pipeline).
  140.      */
  141.  
  142.     if (filePtr->f2 != NULL) {
  143.     if (fclose(filePtr->f2) == EOF) {
  144.         Tcl_AppendResult(interp, "error closing \"", argv[1],
  145.             "\": ", Tcl_UnixError(interp), "\n", (char *) NULL);
  146.         result = TCL_ERROR;
  147.     }
  148.     }
  149.     if (fclose(filePtr->f) == EOF) {
  150.     Tcl_AppendResult(interp, "error closing \"", argv[1],
  151.         "\": ", Tcl_UnixError(interp), "\n", (char *) NULL);
  152.     result = TCL_ERROR;
  153.     }
  154.  
  155.     /*
  156.      * If the file was a connection to a pipeline, clean up everything
  157.      * associated with the child processes.
  158.      */
  159.  
  160.     if (filePtr->numPids > 0) {
  161.     if (CleanupChildren(interp, filePtr->numPids, filePtr->pidPtr,
  162.         filePtr->errorId) != TCL_OK) {
  163.         result = TCL_ERROR;
  164.     }
  165.     }
  166.  
  167.     ckfree((char *) filePtr);
  168.     return result;
  169. }
  170.  
  171. /*
  172.  *----------------------------------------------------------------------
  173.  *
  174.  * Tcl_EofCmd --
  175.  *
  176.  *    This procedure is invoked to process the "eof" Tcl command.
  177.  *    See the user documentation for details on what it does.
  178.  *
  179.  * Results:
  180.  *    A standard Tcl result.
  181.  *
  182.  * Side effects:
  183.  *    See the user documentation.
  184.  *
  185.  *----------------------------------------------------------------------
  186.  */
  187.  
  188.     /* ARGSUSED */
  189. int
  190. Tcl_EofCmd(notUsed, interp, argc, argv)
  191.     ClientData notUsed;            /* Not used. */
  192.     Tcl_Interp *interp;            /* Current interpreter. */
  193.     int argc;                /* Number of arguments. */
  194.     char **argv;            /* Argument strings. */
  195. {
  196.     OpenFile *filePtr;
  197.  
  198.     if (argc != 2) {
  199.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  200.         " fileId\"", (char *) NULL);
  201.     return TCL_ERROR;
  202.     }
  203.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  204.     return TCL_ERROR;
  205.     }
  206.     if (feof(filePtr->f)) {
  207.     interp->result = "1";
  208.     } else {
  209.     interp->result = "0";
  210.     }
  211.     return TCL_OK;
  212. }
  213.  
  214. /*
  215.  *----------------------------------------------------------------------
  216.  *
  217.  * Tcl_ExecCmd --
  218.  *
  219.  *    This procedure is invoked to process the "exec" Tcl command.
  220.  *    See the user documentation for details on what it does.
  221.  *
  222.  * Results:
  223.  *    A standard Tcl result.
  224.  *
  225.  * Side effects:
  226.  *    See the user documentation.
  227.  *
  228.  *----------------------------------------------------------------------
  229.  */
  230.  
  231.     /* ARGSUSED */
  232. int
  233. Tcl_ExecCmd(dummy, interp, argc, argv)
  234.     ClientData dummy;            /* Not used. */
  235.     Tcl_Interp *interp;            /* Current interpreter. */
  236.     int argc;                /* Number of arguments. */
  237.     char **argv;            /* Argument strings. */
  238. {
  239.     int outputId;            /* File id for output pipe.  -1
  240.                      * means command overrode. */
  241.     int errorId;            /* File id for temporary file
  242.                      * containing error output. */
  243.     int *pidPtr;
  244.     int numPids, result;
  245.  
  246.     /*
  247.      * See if the command is to be run in background;  if so, create
  248.      * the command, detach it, and return.
  249.      */
  250.  
  251.     if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) {
  252.     argc--;
  253.     argv[argc] = NULL;
  254.     numPids = Tcl_CreatePipeline(interp, argc-1, argv+1, &pidPtr,
  255.         (int *) NULL, (int *) NULL, (int *) NULL);
  256.     if (numPids < 0) {
  257.         return TCL_ERROR;
  258.     }
  259.     Tcl_DetachPids(numPids, pidPtr);
  260.     ckfree((char *) pidPtr);
  261.     return TCL_OK;
  262.     }
  263.  
  264.     /*
  265.      * Create the command's pipeline.
  266.      */
  267.  
  268.     numPids = Tcl_CreatePipeline(interp, argc-1, argv+1, &pidPtr,
  269.         (int *) NULL, &outputId, &errorId);
  270.     if (numPids < 0) {
  271.     return TCL_ERROR;
  272.     }
  273.  
  274.     /*
  275.      * Read the child's output (if any) and put it into the result.
  276.      */
  277.  
  278.     result = TCL_OK;
  279.     if (outputId != -1) {
  280.     while (1) {
  281. #        define BUFFER_SIZE 1000
  282.         char buffer[BUFFER_SIZE+1];
  283.         int count;
  284.     
  285.         count = read(outputId, buffer, BUFFER_SIZE);
  286.     
  287.         if (count == 0) {
  288.         break;
  289.         }
  290.         if (count < 0) {
  291.         Tcl_ResetResult(interp);
  292.         Tcl_AppendResult(interp,
  293.             "error reading from output pipe: ",
  294.             Tcl_UnixError(interp), (char *) NULL);
  295.         result = TCL_ERROR;
  296.         break;
  297.         }
  298.         buffer[count] = 0;
  299.         Tcl_AppendResult(interp, buffer, (char *) NULL);
  300.     }
  301.     close(outputId);
  302.     }
  303.  
  304.     if (CleanupChildren(interp, numPids, pidPtr, errorId) != TCL_OK) {
  305.     result = TCL_ERROR;
  306.     }
  307.     return result;
  308. }
  309.  
  310. /*
  311.  *----------------------------------------------------------------------
  312.  *
  313.  * Tcl_ExitCmd --
  314.  *
  315.  *    This procedure is invoked to process the "exit" Tcl command.
  316.  *    See the user documentation for details on what it does.
  317.  *
  318.  * Results:
  319.  *    A standard Tcl result.
  320.  *
  321.  * Side effects:
  322.  *    See the user documentation.
  323.  *
  324.  *----------------------------------------------------------------------
  325.  */
  326.  
  327.     /* ARGSUSED */
  328. int
  329. Tcl_ExitCmd(dummy, interp, argc, argv)
  330.     ClientData dummy;            /* Not used. */
  331.     Tcl_Interp *interp;            /* Current interpreter. */
  332.     int argc;                /* Number of arguments. */
  333.     char **argv;            /* Argument strings. */
  334. {
  335.     int value;
  336.  
  337.     if ((argc != 1) && (argc != 2)) {
  338.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  339.         " ?returnCode?\"", (char *) NULL);
  340.     return TCL_ERROR;
  341.     }
  342.     if (argc == 1) {
  343.     exit(0);
  344.     }
  345.     if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) {
  346.     return TCL_ERROR;
  347.     }
  348.     exit(value);
  349.     return TCL_OK;            /* Better not ever reach this! */
  350. }
  351.  
  352. /*
  353.  *----------------------------------------------------------------------
  354.  *
  355.  * Tcl_FileCmd --
  356.  *
  357.  *    This procedure is invoked to process the "file" Tcl command.
  358.  *    See the user documentation for details on what it does.
  359.  *
  360.  * Results:
  361.  *    A standard Tcl result.
  362.  *
  363.  * Side effects:
  364.  *    See the user documentation.
  365.  *
  366.  *----------------------------------------------------------------------
  367.  */
  368.  
  369.     /* ARGSUSED */
  370. int
  371. Tcl_FileCmd(dummy, interp, argc, argv)
  372.     ClientData dummy;            /* Not used. */
  373.     Tcl_Interp *interp;            /* Current interpreter. */
  374.     int argc;                /* Number of arguments. */
  375.     char **argv;            /* Argument strings. */
  376. {
  377.     char *p;
  378.     int length, statOp;
  379.     int mode = 0;            /* Initialized only to prevent
  380.                      * compiler warning message. */
  381.     struct stat statBuf;
  382.     char *fileName, c;
  383.  
  384.     if (argc < 3) {
  385.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  386.         " option name ?arg ...?\"", (char *) NULL);
  387.     return TCL_ERROR;
  388.     }
  389.     c = argv[1][0];
  390.     length = strlen(argv[1]);
  391.  
  392.     /*
  393.      * First handle operations on the file name.
  394.      */
  395.  
  396.     fileName = Tcl_TildeSubst(interp, argv[2]);
  397.     if (fileName == NULL) {
  398.     return TCL_ERROR;
  399.     }
  400.     if ((c == 'd') && (strncmp(argv[1], "dirname", length) == 0)) {
  401.     if (argc != 3) {
  402.         argv[1] = "dirname";
  403.         not3Args:
  404.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  405.             " ", argv[1], " name\"", (char *) NULL);
  406.         return TCL_ERROR;
  407.     }
  408.     p = strrchr(fileName, '/');
  409.     if (p == NULL) {
  410.         interp->result = ".";
  411.     } else if (p == fileName) {
  412.         interp->result = "/";
  413.     } else {
  414.         *p = 0;
  415.         Tcl_SetResult(interp, fileName, TCL_VOLATILE);
  416.         *p = '/';
  417.     }
  418.     return TCL_OK;
  419.     } else if ((c == 'r') && (strncmp(argv[1], "rootname", length) == 0)
  420.         && (length >= 2)) {
  421.     char *lastSlash;
  422.  
  423.     if (argc != 3) {
  424.         argv[1] = "rootname";
  425.         goto not3Args;
  426.     }
  427.     p = strrchr(fileName, '.');
  428.     lastSlash = strrchr(fileName, '/');
  429.     if ((p == NULL) || ((lastSlash != NULL) && (lastSlash > p))) {
  430.         Tcl_SetResult(interp, fileName, TCL_VOLATILE);
  431.     } else {
  432.         *p = 0;
  433.         Tcl_SetResult(interp, fileName, TCL_VOLATILE);
  434.         *p = '.';
  435.     }
  436.     return TCL_OK;
  437.     } else if ((c == 'e') && (strncmp(argv[1], "extension", length) == 0)
  438.         && (length >= 3)) {
  439.     char *lastSlash;
  440.  
  441.     if (argc != 3) {
  442.         argv[1] = "extension";
  443.         goto not3Args;
  444.     }
  445.     p = strrchr(fileName, '.');
  446.     lastSlash = strrchr(fileName, '/');
  447.     if ((p != NULL) && ((lastSlash == NULL) || (lastSlash < p))) {
  448.         Tcl_SetResult(interp, p, TCL_VOLATILE);
  449.     }
  450.     return TCL_OK;
  451.     } else if ((c == 't') && (strncmp(argv[1], "tail", length) == 0)
  452.         && (length >= 2)) {
  453.     if (argc != 3) {
  454.         argv[1] = "tail";
  455.         goto not3Args;
  456.     }
  457.     p = strrchr(fileName, '/');
  458.     if (p != NULL) {
  459.         Tcl_SetResult(interp, p+1, TCL_VOLATILE);
  460.     } else {
  461.         Tcl_SetResult(interp, fileName, TCL_VOLATILE);
  462.     }
  463.     return TCL_OK;
  464.     }
  465.  
  466.     /*
  467.      * Next, handle operations that can be satisfied with the "access"
  468.      * kernel call.
  469.      */
  470.  
  471.     if (fileName == NULL) {
  472.     return TCL_ERROR;
  473.     }
  474.     if ((c == 'r') && (strncmp(argv[1], "readable", length) == 0)
  475.         && (length >= 5)) {
  476.     if (argc != 3) {
  477.         argv[1] = "readable";
  478.         goto not3Args;
  479.     }
  480.     mode = R_OK;
  481.     checkAccess:
  482.     if (access(fileName, mode) == -1) {
  483.         interp->result = "0";
  484.     } else {
  485.         interp->result = "1";
  486.     }
  487.     return TCL_OK;
  488.     } else if ((c == 'w') && (strncmp(argv[1], "writable", length) == 0)) {
  489.     if (argc != 3) {
  490.         argv[1] = "writable";
  491.         goto not3Args;
  492.     }
  493.     mode = W_OK;
  494.     goto checkAccess;
  495.     } else if ((c == 'e') && (strncmp(argv[1], "executable", length) == 0)
  496.         && (length >= 3)) {
  497.     if (argc != 3) {
  498.         argv[1] = "executable";
  499.         goto not3Args;
  500.     }
  501.     mode = X_OK;
  502.     goto checkAccess;
  503.     } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)
  504.         && (length >= 3)) {
  505.     if (argc != 3) {
  506.         argv[1] = "exists";
  507.         goto not3Args;
  508.     }
  509.     mode = F_OK;
  510.     goto checkAccess;
  511.     }
  512.  
  513.     /*
  514.      * Lastly, check stuff that requires the file to be stat-ed.
  515.      */
  516.  
  517.     if ((c == 'a') && (strncmp(argv[1], "atime", length) == 0)) {
  518.     if (argc != 3) {
  519.         argv[1] = "atime";
  520.         goto not3Args;
  521.     }
  522.     if (stat(fileName, &statBuf) == -1) {
  523.         goto badStat;
  524.     }
  525.     sprintf(interp->result, "%ld", statBuf.st_atime);
  526.     return TCL_OK;
  527.     } else if ((c == 'i') && (strncmp(argv[1], "isdirectory", length) == 0)
  528.         && (length >= 3)) {
  529.     if (argc != 3) {
  530.         argv[1] = "isdirectory";
  531.         goto not3Args;
  532.     }
  533.     statOp = 2;
  534.     } else if ((c == 'i') && (strncmp(argv[1], "isfile", length) == 0)
  535.         && (length >= 3)) {
  536.     if (argc != 3) {
  537.         argv[1] = "isfile";
  538.         goto not3Args;
  539.     }
  540.     statOp = 1;
  541.     } else if ((c == 'l') && (strncmp(argv[1], "lstat", length) == 0)) {
  542.     if (argc != 4) {
  543.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  544.             " lstat name varName\"", (char *) NULL);
  545.         return TCL_ERROR;
  546.     }
  547.  
  548.     if (lstat(fileName, &statBuf) == -1) {
  549.         Tcl_AppendResult(interp, "couldn't lstat \"", argv[2],
  550.             "\": ", Tcl_UnixError(interp), (char *) NULL);
  551.         return TCL_ERROR;
  552.     }
  553.     return StoreStatData(interp, argv[3], &statBuf);
  554.     } else if ((c == 'm') && (strncmp(argv[1], "mtime", length) == 0)) {
  555.     if (argc != 3) {
  556.         argv[1] = "mtime";
  557.         goto not3Args;
  558.     }
  559.     if (stat(fileName, &statBuf) == -1) {
  560.         goto badStat;
  561.     }
  562.     sprintf(interp->result, "%ld", statBuf.st_mtime);
  563.     return TCL_OK;
  564.     } else if ((c == 'o') && (strncmp(argv[1], "owned", length) == 0)) {
  565.     if (argc != 3) {
  566.         argv[1] = "owned";
  567.         goto not3Args;
  568.     }
  569.     statOp = 0;
  570. #ifdef S_IFLNK
  571.     /*
  572.      * This option is only included if symbolic links exist on this system
  573.      * (in which case S_IFLNK should be defined).
  574.      */
  575.     } else if ((c == 'r') && (strncmp(argv[1], "readlink", length) == 0)
  576.         && (length >= 5)) {
  577.     char linkValue[MAXPATHLEN+1];
  578.     int linkLength;
  579.  
  580.     if (argc != 3) {
  581.         argv[1] = "readlink";
  582.         goto not3Args;
  583.     }
  584.     linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1);
  585.     if (linkLength == -1) {
  586.         Tcl_AppendResult(interp, "couldn't readlink \"", argv[2],
  587.             "\": ", Tcl_UnixError(interp), (char *) NULL);
  588.         return TCL_ERROR;
  589.     }
  590.     linkValue[linkLength] = 0;
  591.     Tcl_SetResult(interp, linkValue, TCL_VOLATILE);
  592.     return TCL_OK;
  593. #endif
  594.     } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
  595.         && (length >= 2)) {
  596.     if (argc != 3) {
  597.         argv[1] = "size";
  598.         goto not3Args;
  599.     }
  600.     if (stat(fileName, &statBuf) == -1) {
  601.         goto badStat;
  602.     }
  603.     sprintf(interp->result, "%ld", statBuf.st_size);
  604.     return TCL_OK;
  605.     } else if ((c == 's') && (strncmp(argv[1], "stat", length) == 0)
  606.         && (length >= 2)) {
  607.     if (argc != 4) {
  608.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  609.             " stat name varName\"", (char *) NULL);
  610.         return TCL_ERROR;
  611.     }
  612.  
  613.     if (stat(fileName, &statBuf) == -1) {
  614.         badStat:
  615.         Tcl_AppendResult(interp, "couldn't stat \"", argv[2],
  616.             "\": ", Tcl_UnixError(interp), (char *) NULL);
  617.         return TCL_ERROR;
  618.     }
  619.     return StoreStatData(interp, argv[3], &statBuf);
  620.     } else if ((c == 't') && (strncmp(argv[1], "type", length) == 0)
  621.         && (length >= 2)) {
  622.     if (argc != 3) {
  623.         argv[1] = "type";
  624.         goto not3Args;
  625.     }
  626.     if (lstat(fileName, &statBuf) == -1) {
  627.         goto badStat;
  628.     }
  629.     interp->result = GetFileType((int) statBuf.st_mode);
  630.     return TCL_OK;
  631.     } else {
  632.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  633.         "\": should be atime, dirname, executable, exists, ",
  634.         "extension, isdirectory, isfile, lstat, mtime, owned, ",
  635.         "readable, ",
  636. #ifdef S_IFLNK
  637.         "readlink, ",
  638. #endif
  639.         "root, size, stat, tail, type, ",
  640.         "or writable",
  641.         (char *) NULL);
  642.     return TCL_ERROR;
  643.     }
  644.     if (stat(fileName, &statBuf) == -1) {
  645.     interp->result = "0";
  646.     return TCL_OK;
  647.     }
  648.     switch (statOp) {
  649.     case 0:
  650.         mode = (geteuid() == statBuf.st_uid);
  651.         break;
  652.     case 1:
  653.         mode = S_ISREG(statBuf.st_mode);
  654.         break;
  655.     case 2:
  656.         mode = S_ISDIR(statBuf.st_mode);
  657.         break;
  658.     }
  659.     if (mode) {
  660.     interp->result = "1";
  661.     } else {
  662.     interp->result = "0";
  663.     }
  664.     return TCL_OK;
  665. }
  666.  
  667. /*
  668.  *----------------------------------------------------------------------
  669.  *
  670.  * StoreStatData --
  671.  *
  672.  *    This is a utility procedure that breaks out the fields of a
  673.  *    "stat" structure and stores them in textual form into the
  674.  *    elements of an associative array.
  675.  *
  676.  * Results:
  677.  *    Returns a standard Tcl return value.  If an error occurs then
  678.  *    a message is left in interp->result.
  679.  *
  680.  * Side effects:
  681.  *    Elements of the associative array given by "varName" are modified.
  682.  *
  683.  *----------------------------------------------------------------------
  684.  */
  685.  
  686. static int
  687. StoreStatData(interp, varName, statPtr)
  688.     Tcl_Interp *interp;            /* Interpreter for error reports. */
  689.     char *varName;            /* Name of associative array variable
  690.                      * in which to store stat results. */
  691.     struct stat *statPtr;        /* Pointer to buffer containing
  692.                      * stat data to store in varName. */
  693. {
  694.     char string[30];
  695.  
  696.     sprintf(string, "%d", statPtr->st_dev);
  697.     if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG)
  698.         == NULL) {
  699.     return TCL_ERROR;
  700.     }
  701.     sprintf(string, "%d", statPtr->st_ino);
  702.     if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG)
  703.         == NULL) {
  704.     return TCL_ERROR;
  705.     }
  706.     sprintf(string, "%d", statPtr->st_mode);
  707.     if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG)
  708.         == NULL) {
  709.     return TCL_ERROR;
  710.     }
  711.     sprintf(string, "%d", statPtr->st_nlink);
  712.     if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG)
  713.         == NULL) {
  714.     return TCL_ERROR;
  715.     }
  716.     sprintf(string, "%d", statPtr->st_uid);
  717.     if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG)
  718.         == NULL) {
  719.     return TCL_ERROR;
  720.     }
  721.     sprintf(string, "%d", statPtr->st_gid);
  722.     if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG)
  723.         == NULL) {
  724.     return TCL_ERROR;
  725.     }
  726.     sprintf(string, "%ld", statPtr->st_size);
  727.     if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG)
  728.         == NULL) {
  729.     return TCL_ERROR;
  730.     }
  731.     sprintf(string, "%ld", statPtr->st_atime);
  732.     if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG)
  733.         == NULL) {
  734.     return TCL_ERROR;
  735.     }
  736.     sprintf(string, "%ld", statPtr->st_mtime);
  737.     if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG)
  738.         == NULL) {
  739.     return TCL_ERROR;
  740.     }
  741.     sprintf(string, "%ld", statPtr->st_ctime);
  742.     if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG)
  743.         == NULL) {
  744.     return TCL_ERROR;
  745.     }
  746.     if (Tcl_SetVar2(interp, varName, "type",
  747.         GetFileType((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) {
  748.     return TCL_ERROR;
  749.     }
  750.     return TCL_OK;
  751. }
  752.  
  753. /*
  754.  *----------------------------------------------------------------------
  755.  *
  756.  * GetFileType --
  757.  *
  758.  *    Given a mode word, returns a string identifying the type of a
  759.  *    file.
  760.  *
  761.  * Results:
  762.  *    A static text string giving the file type from mode.
  763.  *
  764.  * Side effects:
  765.  *    None.
  766.  *
  767.  *----------------------------------------------------------------------
  768.  */
  769.  
  770. static char *
  771. GetFileType(mode)
  772.     int mode;
  773. {
  774.     if (S_ISREG(mode)) {
  775.     return "file";
  776.     } else if (S_ISDIR(mode)) {
  777.     return "directory";
  778.     } else if (S_ISCHR(mode)) {
  779.     return "characterSpecial";
  780.     } else if (S_ISBLK(mode)) {
  781.     return "blockSpecial";
  782.     } else if (S_ISFIFO(mode)) {
  783.     return "fifo";
  784.     } else if (S_ISLNK(mode)) {
  785.     return "link";
  786.     } else if (S_ISSOCK(mode)) {
  787.     return "socket";
  788.     }
  789.     return "unknown";
  790. }
  791.  
  792. /*
  793.  *----------------------------------------------------------------------
  794.  *
  795.  * Tcl_FlushCmd --
  796.  *
  797.  *    This procedure is invoked to process the "flush" Tcl command.
  798.  *    See the user documentation for details on what it does.
  799.  *
  800.  * Results:
  801.  *    A standard Tcl result.
  802.  *
  803.  * Side effects:
  804.  *    See the user documentation.
  805.  *
  806.  *----------------------------------------------------------------------
  807.  */
  808.  
  809.     /* ARGSUSED */
  810. int
  811. Tcl_FlushCmd(notUsed, interp, argc, argv)
  812.     ClientData notUsed;            /* Not used. */
  813.     Tcl_Interp *interp;            /* Current interpreter. */
  814.     int argc;                /* Number of arguments. */
  815.     char **argv;            /* Argument strings. */
  816. {
  817.     OpenFile *filePtr;
  818.     FILE *f;
  819.  
  820.     if (argc != 2) {
  821.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  822.         " fileId\"", (char *) NULL);
  823.     return TCL_ERROR;
  824.     }
  825.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  826.     return TCL_ERROR;
  827.     }
  828.     if (!filePtr->writable) {
  829.     Tcl_AppendResult(interp, "\"", argv[1],
  830.         "\" wasn't opened for writing", (char *) NULL);
  831.     return TCL_ERROR;
  832.     }
  833.     f = filePtr->f2;
  834.     if (f == NULL) {
  835.     f = filePtr->f;
  836.     }
  837.     if (fflush(f) == EOF) {
  838.     Tcl_AppendResult(interp, "error flushing \"", argv[1],
  839.         "\": ", Tcl_UnixError(interp), (char *) NULL);
  840.     clearerr(f);
  841.     return TCL_ERROR;
  842.     }
  843.     return TCL_OK;
  844. }
  845.  
  846. /*
  847.  *----------------------------------------------------------------------
  848.  *
  849.  * Tcl_GetsCmd --
  850.  *
  851.  *    This procedure is invoked to process the "gets" Tcl command.
  852.  *    See the user documentation for details on what it does.
  853.  *
  854.  * Results:
  855.  *    A standard Tcl result.
  856.  *
  857.  * Side effects:
  858.  *    See the user documentation.
  859.  *
  860.  *----------------------------------------------------------------------
  861.  */
  862.  
  863.     /* ARGSUSED */
  864. int
  865. Tcl_GetsCmd(notUsed, interp, argc, argv)
  866.     ClientData notUsed;            /* Not used. */
  867.     Tcl_Interp *interp;            /* Current interpreter. */
  868.     int argc;                /* Number of arguments. */
  869.     char **argv;            /* Argument strings. */
  870. {
  871. #   define BUF_SIZE 200
  872.     char buffer[BUF_SIZE+1];
  873.     int totalCount, done, flags;
  874.     OpenFile *filePtr;
  875.     register FILE *f;
  876.  
  877.     if ((argc != 2) && (argc != 3)) {
  878.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  879.         " fileId ?varName?\"", (char *) NULL);
  880.     return TCL_ERROR;
  881.     }
  882.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  883.     return TCL_ERROR;
  884.     }
  885.     if (!filePtr->readable) {
  886.     Tcl_AppendResult(interp, "\"", argv[1],
  887.         "\" wasn't opened for reading", (char *) NULL);
  888.     return TCL_ERROR;
  889.     }
  890.  
  891.     /*
  892.      * We can't predict how large a line will be, so read it in
  893.      * pieces, appending to the current result or to a variable.
  894.      */
  895.  
  896.     totalCount = 0;
  897.     done = 0;
  898.     flags = 0;
  899.     f = filePtr->f;
  900.     while (!done) {
  901.     register int c, count;
  902.     register char *p;
  903.  
  904.     for (p = buffer, count = 0; count < BUF_SIZE-1; count++, p++) {
  905.         c = getc(f);
  906.         if (c == EOF) {
  907.         if (ferror(filePtr->f)) {
  908.             Tcl_ResetResult(interp);
  909.             Tcl_AppendResult(interp, "error reading \"", argv[1],
  910.                 "\": ", Tcl_UnixError(interp), (char *) NULL);
  911.             clearerr(filePtr->f);
  912.             return TCL_ERROR;
  913.         } else if (feof(filePtr->f)) {
  914.             if ((totalCount == 0) && (count == 0)) {
  915.             totalCount = -1;
  916.             }
  917.             done = 1;
  918.             break;
  919.         }
  920.         }
  921.         if (c == '\n') {
  922.         done = 1;
  923.         break;
  924.         }
  925.         *p = c;
  926.     }
  927.     *p = 0;
  928.     if (argc == 2) {
  929.         Tcl_AppendResult(interp, buffer, (char *) NULL);
  930.     } else {
  931.         if (Tcl_SetVar(interp, argv[2], buffer, flags|TCL_LEAVE_ERR_MSG)
  932.             == NULL) {
  933.         return TCL_ERROR;
  934.         }
  935.         flags = TCL_APPEND_VALUE;
  936.     }
  937.     totalCount += count;
  938.     }
  939.  
  940.     if (argc == 3) {
  941.     sprintf(interp->result, "%d", totalCount);
  942.     }
  943.     return TCL_OK;
  944. }
  945.  
  946. /*
  947.  *----------------------------------------------------------------------
  948.  *
  949.  * Tcl_OpenCmd --
  950.  *
  951.  *    This procedure is invoked to process the "open" Tcl command.
  952.  *    See the user documentation for details on what it does.
  953.  *
  954.  * Results:
  955.  *    A standard Tcl result.
  956.  *
  957.  * Side effects:
  958.  *    See the user documentation.
  959.  *
  960.  *----------------------------------------------------------------------
  961.  */
  962.  
  963.     /* ARGSUSED */
  964. int
  965. Tcl_OpenCmd(notUsed, interp, argc, argv)
  966.     ClientData notUsed;            /* Not used. */
  967.     Tcl_Interp *interp;            /* Current interpreter. */
  968.     int argc;                /* Number of arguments. */
  969.     char **argv;            /* Argument strings. */
  970. {
  971.     Interp *iPtr = (Interp *) interp;
  972.     int pipeline, fd;
  973.     char *access;
  974.     register OpenFile *filePtr;
  975.  
  976.     if (argc == 2) {
  977.     access = "r";
  978.     } else if (argc == 3) {
  979.     access = argv[2];
  980.     } else {
  981.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  982.         " filename ?access?\"", (char *) NULL);
  983.     return TCL_ERROR;
  984.     }
  985.  
  986.     filePtr = (OpenFile *) ckalloc(sizeof(OpenFile));
  987.     filePtr->f = NULL;
  988.     filePtr->f2 = NULL;
  989.     filePtr->readable = 0;
  990.     filePtr->writable = 0;
  991.     filePtr->numPids = 0;
  992.     filePtr->pidPtr = NULL;
  993.     filePtr->errorId = -1;
  994.  
  995.     /*
  996.      * Verify the requested form of access.
  997.      */
  998.  
  999.     pipeline = 0;
  1000.     if (argv[1][0] == '|') {
  1001.     pipeline = 1;
  1002.     }
  1003.     switch (access[0]) {
  1004.     case 'r':
  1005.         filePtr->readable = 1;
  1006.         break;
  1007.     case 'w':
  1008.         filePtr->writable = 1;
  1009.         break;
  1010.     case 'a':
  1011.         filePtr->writable = 1;
  1012.         break;
  1013.     default:
  1014.         badAccess:
  1015.         Tcl_AppendResult(interp, "illegal access mode \"", access,
  1016.             "\"", (char *) NULL);
  1017.         goto error;
  1018.     }
  1019.     if (access[1] == '+') {
  1020.     filePtr->readable = filePtr->writable = 1;
  1021.     if (access[2] != 0) {
  1022.         goto badAccess;
  1023.     }
  1024.     } else if (access[1] != 0) {
  1025.     goto badAccess;
  1026.     }
  1027.  
  1028.     /*
  1029.      * Open the file or create a process pipeline.
  1030.      */
  1031.  
  1032.     if (!pipeline) {
  1033.     char *fileName = argv[1];
  1034.  
  1035.     if (fileName[0] == '~') {
  1036.         fileName = Tcl_TildeSubst(interp, fileName);
  1037.         if (fileName == NULL) {
  1038.         goto error;
  1039.         }
  1040.     }
  1041.     filePtr->f = fopen(fileName, access);
  1042.     if (filePtr->f == NULL) {
  1043.         Tcl_AppendResult(interp, "couldn't open \"", argv[1],
  1044.             "\": ", Tcl_UnixError(interp), (char *) NULL);
  1045.         goto error;
  1046.     }
  1047.     } else {
  1048.     int *inPipePtr, *outPipePtr;
  1049.     int cmdArgc, inPipe, outPipe;
  1050.     char **cmdArgv;
  1051.  
  1052.     if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) {
  1053.         goto error;
  1054.     }
  1055.     inPipePtr = (filePtr->writable) ? &inPipe : NULL;
  1056.     outPipePtr = (filePtr->readable) ? &outPipe : NULL;
  1057.     inPipe = outPipe = -1;
  1058.     filePtr->numPids = Tcl_CreatePipeline(interp, cmdArgc, cmdArgv,
  1059.         &filePtr->pidPtr, inPipePtr, outPipePtr, &filePtr->errorId);
  1060.     ckfree((char *) cmdArgv);
  1061.     if (filePtr->numPids < 0) {
  1062.         goto error;
  1063.     }
  1064.     if (filePtr->readable) {
  1065.         if (outPipe == -1) {
  1066.         if (inPipe != -1) {
  1067.             close(inPipe);
  1068.         }
  1069.         Tcl_AppendResult(interp, "can't read output from command:",
  1070.             " standard output was redirected", (char *) NULL);
  1071.         goto error;
  1072.         }
  1073.         filePtr->f = fdopen(outPipe, "r");
  1074.     }
  1075.     if (filePtr->writable) {
  1076.         if (inPipe == -1) {
  1077.         Tcl_AppendResult(interp, "can't write input to command:",
  1078.             " standard input was redirected", (char *) NULL);
  1079.         goto error;
  1080.         }
  1081.         if (filePtr->f != NULL) {
  1082.         filePtr->f2 = fdopen(inPipe, "w");
  1083.         } else {
  1084.         filePtr->f = fdopen(inPipe, "w");
  1085.         }
  1086.     }
  1087.     }
  1088.  
  1089.     /*
  1090.      * Enter this new OpenFile structure in the table for the
  1091.      * interpreter.  May have to expand the table to do this.
  1092.      */
  1093.  
  1094.     fd = fileno(filePtr->f);
  1095.     TclMakeFileTable(iPtr, fd);
  1096.     if (iPtr->filePtrArray[fd] != NULL) {
  1097.     panic("Tcl_OpenCmd found file already open");
  1098.     }
  1099.     iPtr->filePtrArray[fd] = filePtr;
  1100.     sprintf(interp->result, "file%d", fd);
  1101.     return TCL_OK;
  1102.  
  1103.     error:
  1104.     if (filePtr->f != NULL) {
  1105.     fclose(filePtr->f);
  1106.     }
  1107.     if (filePtr->f2 != NULL) {
  1108.     fclose(filePtr->f2);
  1109.     }
  1110.     if (filePtr->numPids > 0) {
  1111.     Tcl_DetachPids(filePtr->numPids, filePtr->pidPtr);
  1112.     ckfree((char *) filePtr->pidPtr);
  1113.     }
  1114.     if (filePtr->errorId != -1) {
  1115.     close(filePtr->errorId);
  1116.     }
  1117.     ckfree((char *) filePtr);
  1118.     return TCL_ERROR;
  1119. }
  1120.  
  1121. /*
  1122.  *----------------------------------------------------------------------
  1123.  *
  1124.  * Tcl_PwdCmd --
  1125.  *
  1126.  *    This procedure is invoked to process the "pwd" Tcl command.
  1127.  *    See the user documentation for details on what it does.
  1128.  *
  1129.  * Results:
  1130.  *    A standard Tcl result.
  1131.  *
  1132.  * Side effects:
  1133.  *    See the user documentation.
  1134.  *
  1135.  *----------------------------------------------------------------------
  1136.  */
  1137.  
  1138.     /* ARGSUSED */
  1139. int
  1140. Tcl_PwdCmd(dummy, interp, argc, argv)
  1141.     ClientData dummy;            /* Not used. */
  1142.     Tcl_Interp *interp;            /* Current interpreter. */
  1143.     int argc;                /* Number of arguments. */
  1144.     char **argv;            /* Argument strings. */
  1145. {
  1146.     char buffer[MAXPATHLEN+1];
  1147.  
  1148.     if (argc != 1) {
  1149.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1150.         argv[0], "\"", (char *) NULL);
  1151.     return TCL_ERROR;
  1152.     }
  1153.     if (currentDir == NULL) {
  1154. #if TCL_GETWD
  1155.     if (getwd(buffer) == NULL) {
  1156.         Tcl_AppendResult(interp, "error getting working directory name: ",
  1157.             buffer, (char *) NULL);
  1158.         return TCL_ERROR;
  1159.     }
  1160. #else
  1161.     if (getcwd(buffer, MAXPATHLEN) == NULL) {
  1162.         if (errno == ERANGE) {
  1163.         interp->result = "working directory name is too long";
  1164.         } else {
  1165.         Tcl_AppendResult(interp,
  1166.             "error getting working directory name: ",
  1167.             Tcl_UnixError(interp), (char *) NULL);
  1168.         }
  1169.         return TCL_ERROR;
  1170.     }
  1171. #endif
  1172.     currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1));
  1173.     strcpy(currentDir, buffer);
  1174.     }
  1175.     interp->result = currentDir;
  1176.     return TCL_OK;
  1177. }
  1178.  
  1179. /*
  1180.  *----------------------------------------------------------------------
  1181.  *
  1182.  * Tcl_PutsCmd --
  1183.  *
  1184.  *    This procedure is invoked to process the "puts" Tcl command.
  1185.  *    See the user documentation for details on what it does.
  1186.  *
  1187.  * Results:
  1188.  *    A standard Tcl result.
  1189.  *
  1190.  * Side effects:
  1191.  *    See the user documentation.
  1192.  *
  1193.  *----------------------------------------------------------------------
  1194.  */
  1195.  
  1196.     /* ARGSUSED */
  1197. int
  1198. Tcl_PutsCmd(dummy, interp, argc, argv)
  1199.     ClientData dummy;            /* Not used. */
  1200.     Tcl_Interp *interp;            /* Current interpreter. */
  1201.     int argc;                /* Number of arguments. */
  1202.     char **argv;            /* Argument strings. */
  1203. {
  1204.     OpenFile *filePtr;
  1205.     FILE *f;
  1206.  
  1207.     if (argc == 4) {
  1208.     if (strncmp(argv[3], "nonewline", strlen(argv[3])) != 0) {
  1209.         Tcl_AppendResult(interp, "bad argument \"", argv[3],
  1210.             "\": should be \"nonewline\"", (char *) NULL);
  1211.         return TCL_ERROR;
  1212.     }
  1213.     } else if (argc != 3) {
  1214.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1215.         " fileId string ?nonewline?\"", (char *) NULL);
  1216.     return TCL_ERROR;
  1217.     }
  1218.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  1219.     return TCL_ERROR;
  1220.     }
  1221.     if (!filePtr->writable) {
  1222.     Tcl_AppendResult(interp, "\"", argv[1],
  1223.         "\" wasn't opened for writing", (char *) NULL);
  1224.     return TCL_ERROR;
  1225.     }
  1226.  
  1227.     f = filePtr->f2;
  1228.     if (f == NULL) {
  1229.     f = filePtr->f;
  1230.     }
  1231.     fputs(argv[2], f);
  1232.     if (argc == 3) {
  1233.     fputc('\n', f);
  1234.     }
  1235.     if (ferror(f)) {
  1236.     Tcl_AppendResult(interp, "error writing \"", argv[1],
  1237.         "\": ", Tcl_UnixError(interp), (char *) NULL);
  1238.     clearerr(f);
  1239.     return TCL_ERROR;
  1240.     }
  1241.     return TCL_OK;
  1242. }
  1243.  
  1244. /*
  1245.  *----------------------------------------------------------------------
  1246.  *
  1247.  * Tcl_ReadCmd --
  1248.  *
  1249.  *    This procedure is invoked to process the "read" Tcl command.
  1250.  *    See the user documentation for details on what it does.
  1251.  *
  1252.  * Results:
  1253.  *    A standard Tcl result.
  1254.  *
  1255.  * Side effects:
  1256.  *    See the user documentation.
  1257.  *
  1258.  *----------------------------------------------------------------------
  1259.  */
  1260.  
  1261.     /* ARGSUSED */
  1262. int
  1263. Tcl_ReadCmd(dummy, interp, argc, argv)
  1264.     ClientData dummy;            /* Not used. */
  1265.     Tcl_Interp *interp;            /* Current interpreter. */
  1266.     int argc;                /* Number of arguments. */
  1267.     char **argv;            /* Argument strings. */
  1268. {
  1269.     OpenFile *filePtr;
  1270.     int bytesLeft, bytesRead, count;
  1271. #define READ_BUF_SIZE 4096
  1272.     char buffer[READ_BUF_SIZE+1];
  1273.     int newline;
  1274.  
  1275.     if ((argc != 2) && (argc != 3)) {
  1276.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1277.         " fileId ?numBytes|nonewline?\"", (char *) NULL);
  1278.     return TCL_ERROR;
  1279.     }
  1280.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  1281.     return TCL_ERROR;
  1282.     }
  1283.     if (!filePtr->readable) {
  1284.     Tcl_AppendResult(interp, "\"", argv[1],
  1285.         "\" wasn't opened for reading", (char *) NULL);
  1286.     return TCL_ERROR;
  1287.     }
  1288.  
  1289.     /*
  1290.      * Compute how many bytes to read, and see whether the final
  1291.      * newline should be dropped.
  1292.      */
  1293.  
  1294.     newline = 1;
  1295.     if ((argc > 2) && isdigit(argv[2][0])) {
  1296.     if (Tcl_GetInt(interp, argv[2], &bytesLeft) != TCL_OK) {
  1297.         return TCL_ERROR;
  1298.     }
  1299.     } else {
  1300.     bytesLeft = 1<<30;
  1301.     if (argc > 2) {
  1302.         if (strncmp(argv[2], "nonewline", strlen(argv[2])) == 0) {
  1303.         newline = 0;
  1304.         } else {
  1305.         Tcl_AppendResult(interp, "bad argument \"", argv[2],
  1306.             "\": should be \"nonewline\"", (char *) NULL);
  1307.         return TCL_ERROR;
  1308.         }
  1309.     }
  1310.     }
  1311.  
  1312.     /*
  1313.      * Read the file in one or more chunks.
  1314.      */
  1315.  
  1316.     bytesRead = 0;
  1317.     while (bytesLeft > 0) {
  1318.     count = READ_BUF_SIZE;
  1319.     if (bytesLeft < READ_BUF_SIZE) {
  1320.         count = bytesLeft;
  1321.     }
  1322.     count = fread(buffer, 1, count, filePtr->f);
  1323.     if (ferror(filePtr->f)) {
  1324.         Tcl_ResetResult(interp);
  1325.         Tcl_AppendResult(interp, "error reading \"", argv[1],
  1326.             "\": ", Tcl_UnixError(interp), (char *) NULL);
  1327.         clearerr(filePtr->f);
  1328.         return TCL_ERROR;
  1329.     }
  1330.     if (count == 0) {
  1331.         break;
  1332.     }
  1333.     buffer[count] = 0;
  1334.     Tcl_AppendResult(interp, buffer, (char ) NULL);
  1335.     bytesLeft -= count;
  1336.     bytesRead += count;
  1337.     }
  1338.     if ((newline == 0) && (interp->result[bytesRead-1] == '\n')) {
  1339.     interp->result[bytesRead-1] = 0;
  1340.     }
  1341.     return TCL_OK;
  1342. }
  1343.  
  1344. /*
  1345.  *----------------------------------------------------------------------
  1346.  *
  1347.  * Tcl_SeekCmd --
  1348.  *
  1349.  *    This procedure is invoked to process the "seek" Tcl command.
  1350.  *    See the user documentation for details on what it does.
  1351.  *
  1352.  * Results:
  1353.  *    A standard Tcl result.
  1354.  *
  1355.  * Side effects:
  1356.  *    See the user documentation.
  1357.  *
  1358.  *----------------------------------------------------------------------
  1359.  */
  1360.  
  1361.     /* ARGSUSED */
  1362. int
  1363. Tcl_SeekCmd(notUsed, interp, argc, argv)
  1364.     ClientData notUsed;            /* Not used. */
  1365.     Tcl_Interp *interp;            /* Current interpreter. */
  1366.     int argc;                /* Number of arguments. */
  1367.     char **argv;            /* Argument strings. */
  1368. {
  1369.     OpenFile *filePtr;
  1370.     int offset, mode;
  1371.  
  1372.     if ((argc != 3) && (argc != 4)) {
  1373.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1374.         " fileId offset ?origin?\"", (char *) NULL);
  1375.     return TCL_ERROR;
  1376.     }
  1377.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  1378.     return TCL_ERROR;
  1379.     }
  1380.     if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) {
  1381.     return TCL_ERROR;
  1382.     }
  1383.     mode = SEEK_SET;
  1384.     if (argc == 4) {
  1385.     int length;
  1386.     char c;
  1387.  
  1388.     length = strlen(argv[3]);
  1389.     c = argv[3][0];
  1390.     if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) {
  1391.         mode = SEEK_SET;
  1392.     } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) {
  1393.         mode = SEEK_CUR;
  1394.     } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) {
  1395.         mode = SEEK_END;
  1396.     } else {
  1397.         Tcl_AppendResult(interp, "bad origin \"", argv[3],
  1398.             "\": should be start, current, or end", (char *) NULL);
  1399.         return TCL_ERROR;
  1400.     }
  1401.     }
  1402.     if (fseek(filePtr->f, offset, mode) == -1) {
  1403.     Tcl_AppendResult(interp, "error during seek: ",
  1404.         Tcl_UnixError(interp), (char *) NULL);
  1405.     clearerr(filePtr->f);
  1406.     return TCL_ERROR;
  1407.     }
  1408.  
  1409.     return TCL_OK;
  1410. }
  1411.  
  1412. /*
  1413.  *----------------------------------------------------------------------
  1414.  *
  1415.  * Tcl_SourceCmd --
  1416.  *
  1417.  *    This procedure is invoked to process the "source" Tcl command.
  1418.  *    See the user documentation for details on what it does.
  1419.  *
  1420.  * Results:
  1421.  *    A standard Tcl result.
  1422.  *
  1423.  * Side effects:
  1424.  *    See the user documentation.
  1425.  *
  1426.  *----------------------------------------------------------------------
  1427.  */
  1428.  
  1429.     /* ARGSUSED */
  1430. int
  1431. Tcl_SourceCmd(dummy, interp, argc, argv)
  1432.     ClientData dummy;            /* Not used. */
  1433.     Tcl_Interp *interp;            /* Current interpreter. */
  1434.     int argc;                /* Number of arguments. */
  1435.     char **argv;            /* Argument strings. */
  1436. {
  1437.     if (argc != 2) {
  1438.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1439.         " fileName\"", (char *) NULL);
  1440.     return TCL_ERROR;
  1441.     }
  1442.     return Tcl_EvalFile(interp, argv[1]);
  1443. }
  1444.  
  1445. /*
  1446.  *----------------------------------------------------------------------
  1447.  *
  1448.  * Tcl_TellCmd --
  1449.  *
  1450.  *    This procedure is invoked to process the "tell" Tcl command.
  1451.  *    See the user documentation for details on what it does.
  1452.  *
  1453.  * Results:
  1454.  *    A standard Tcl result.
  1455.  *
  1456.  * Side effects:
  1457.  *    See the user documentation.
  1458.  *
  1459.  *----------------------------------------------------------------------
  1460.  */
  1461.  
  1462.     /* ARGSUSED */
  1463. int
  1464. Tcl_TellCmd(notUsed, interp, argc, argv)
  1465.     ClientData notUsed;            /* Not used. */
  1466.     Tcl_Interp *interp;            /* Current interpreter. */
  1467.     int argc;                /* Number of arguments. */
  1468.     char **argv;            /* Argument strings. */
  1469. {
  1470.     OpenFile *filePtr;
  1471.  
  1472.     if (argc != 2) {
  1473.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1474.         " fileId\"", (char *) NULL);
  1475.     return TCL_ERROR;
  1476.     }
  1477.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  1478.     return TCL_ERROR;
  1479.     }
  1480.     sprintf(interp->result, "%d", ftell(filePtr->f));
  1481.     return TCL_OK;
  1482. }
  1483.  
  1484. /*
  1485.  *----------------------------------------------------------------------
  1486.  *
  1487.  * Tcl_TimeCmd --
  1488.  *
  1489.  *    This procedure is invoked to process the "time" Tcl command.
  1490.  *    See the user documentation for details on what it does.
  1491.  *
  1492.  * Results:
  1493.  *    A standard Tcl result.
  1494.  *
  1495.  * Side effects:
  1496.  *    See the user documentation.
  1497.  *
  1498.  *----------------------------------------------------------------------
  1499.  */
  1500.  
  1501.     /* ARGSUSED */
  1502. int
  1503. Tcl_TimeCmd(dummy, interp, argc, argv)
  1504.     ClientData dummy;            /* Not used. */
  1505.     Tcl_Interp *interp;            /* Current interpreter. */
  1506.     int argc;                /* Number of arguments. */
  1507.     char **argv;            /* Argument strings. */
  1508. {
  1509.     int count, i, result;
  1510.     double timePer;
  1511. #if TCL_GETTOD
  1512.     struct timeval start, stop;
  1513.     struct timezone tz;
  1514.     int micros;
  1515. #else
  1516.     struct tms dummy2;
  1517.     long start, stop;
  1518. #endif
  1519.  
  1520.     if (argc == 2) {
  1521.     count = 1;
  1522.     } else if (argc == 3) {
  1523.     if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
  1524.         return TCL_ERROR;
  1525.     }
  1526.     } else {
  1527.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1528.         " command ?count?\"", (char *) NULL);
  1529.     return TCL_ERROR;
  1530.     }
  1531. #if TCL_GETTOD
  1532.     gettimeofday(&start, &tz);
  1533. #else
  1534.     start = times(&dummy2);
  1535. #endif
  1536.     for (i = count ; i > 0; i--) {
  1537.     result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
  1538.     if (result != TCL_OK) {
  1539.         if (result == TCL_ERROR) {
  1540.         char msg[60];
  1541.         sprintf(msg, "\n    (\"time\" body line %d)",
  1542.             interp->errorLine);
  1543.         Tcl_AddErrorInfo(interp, msg);
  1544.         }
  1545.         return result;
  1546.     }
  1547.     }
  1548. #if TCL_GETTOD
  1549.     gettimeofday(&stop, &tz);
  1550.     micros = (stop.tv_sec - start.tv_sec)*1000000
  1551.         + (stop.tv_usec - start.tv_usec);
  1552.     timePer = micros;
  1553. #else
  1554.     stop = times(&dummy2);
  1555.     timePer = (((double) (stop - start))*1000000.0)/CLK_TCK;
  1556. #endif
  1557.     Tcl_ResetResult(interp);
  1558.     sprintf(interp->result, "%.0f microseconds per iteration", timePer/count);
  1559.     return TCL_OK;
  1560. }
  1561.  
  1562. /*
  1563.  *----------------------------------------------------------------------
  1564.  *
  1565.  * CleanupChildren --
  1566.  *
  1567.  *    This is a utility procedure used to wait for child processes
  1568.  *    to exit, record information about abnormal exits, and then
  1569.  *    collect any stderr output generated by them.
  1570.  *
  1571.  * Results:
  1572.  *    The return value is a standard Tcl result.  If anything at
  1573.  *    weird happened with the child processes, TCL_ERROR is returned
  1574.  *    and a message is left in interp->result.
  1575.  *
  1576.  * Side effects:
  1577.  *    If the last character of interp->result is a newline, then it
  1578.  *    is removed.  File errorId gets closed, and pidPtr is freed
  1579.  *    back to the storage allocator.
  1580.  *
  1581.  *----------------------------------------------------------------------
  1582.  */
  1583.  
  1584. static int
  1585. CleanupChildren(interp, numPids, pidPtr, errorId)
  1586.     Tcl_Interp *interp;        /* Used for error messages. */
  1587.     int numPids;        /* Number of entries in pidPtr array. */
  1588.     int *pidPtr;        /* Array of process ids of children. */
  1589.     int errorId;        /* File descriptor index for file containing
  1590.                  * stderr output from pipeline.  -1 means
  1591.                  * there isn't any stderr output. */
  1592. {
  1593.     int result = TCL_OK;
  1594.     int i, pid, length;
  1595.     WAIT_STATUS_TYPE waitStatus;
  1596.  
  1597.     for (i = 0; i < numPids; i++) {
  1598.     pid = Tcl_WaitPids(1, &pidPtr[i], (int *) &waitStatus);
  1599.     if (pid == -1) {
  1600.         Tcl_AppendResult(interp, "error waiting for process to exit: ",
  1601.             Tcl_UnixError(interp), (char *) NULL);
  1602.         continue;
  1603.     }
  1604.  
  1605.     /*
  1606.      * Create error messages for unusual process exits.  An
  1607.      * extra newline gets appended to each error message, but
  1608.      * it gets removed below (in the same fashion that an
  1609.      * extra newline in the command's output is removed).
  1610.      */
  1611.  
  1612.     if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
  1613.         char msg1[20], msg2[20];
  1614.  
  1615.         result = TCL_ERROR;
  1616.         sprintf(msg1, "%d", pid);
  1617.         if (WIFEXITED(waitStatus)) {
  1618.         sprintf(msg2, "%d", WEXITSTATUS(waitStatus));
  1619.         Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2,
  1620.             (char *) NULL);
  1621.         } else if (WIFSIGNALED(waitStatus)) {
  1622.         char *p;
  1623.     
  1624.         p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus)));
  1625.         Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
  1626.             Tcl_SignalId((int) (WTERMSIG(waitStatus))), p,
  1627.             (char *) NULL);
  1628.         Tcl_AppendResult(interp, "child killed: ", p, "\n",
  1629.             (char *) NULL);
  1630.         } else if (WIFSTOPPED(waitStatus)) {
  1631.         char *p;
  1632.  
  1633.         p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus)));
  1634.         Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
  1635.             Tcl_SignalId((int) (WSTOPSIG(waitStatus))), p, (char *) NULL);
  1636.         Tcl_AppendResult(interp, "child suspended: ", p, "\n",
  1637.             (char *) NULL);
  1638.         } else {
  1639.         Tcl_AppendResult(interp,
  1640.             "child wait status didn't make sense\n",
  1641.             (char *) NULL);
  1642.         }
  1643.     }
  1644.     }
  1645.     ckfree((char *) pidPtr);
  1646.  
  1647.     /*
  1648.      * Read the standard error file.  If there's anything there,
  1649.      * then return an error and add the file's contents to the result
  1650.      * string.
  1651.      */
  1652.  
  1653.     if (errorId >= 0) {
  1654.     while (1) {
  1655. #        define BUFFER_SIZE 1000
  1656.         char buffer[BUFFER_SIZE+1];
  1657.         int count;
  1658.     
  1659.         count = read(errorId, buffer, BUFFER_SIZE);
  1660.     
  1661.         if (count == 0) {
  1662.         break;
  1663.         }
  1664.         if (count < 0) {
  1665.         Tcl_AppendResult(interp,
  1666.             "error reading stderr output file: ",
  1667.             Tcl_UnixError(interp), (char *) NULL);
  1668.         break;
  1669.         }
  1670.         buffer[count] = 0;
  1671.         Tcl_AppendResult(interp, buffer, (char *) NULL);
  1672.     }
  1673.     close(errorId);
  1674.     }
  1675.  
  1676.     /*
  1677.      * If the last character of interp->result is a newline, then remove
  1678.      * the newline character (the newline would just confuse things).
  1679.      */
  1680.  
  1681.     length = strlen(interp->result);
  1682.     if ((length > 0) && (interp->result[length-1] == '\n')) {
  1683.     interp->result[length-1] = '\0';
  1684.     }
  1685.  
  1686.     return result;
  1687. }
  1688.